Manipulation Check
Real / Fake
# plot(estimate_density(filter(df, Participant == "60dd7b03f1e72d38230df476_9yh9n")$Belief_Answer))
df |>
mutate(Participant = fct_relevel(Participant, df |>
group_by(Participant) |>
summarize(Belief_Answer = mean(Belief_Answer)) |>
ungroup() |>
arrange(Belief_Answer) |>
pull(Participant) |>
as.character())) |>
# mutate(Participant = fct_relevel(Participant, as.character(dfsub$Participant))) |>
ggplot(aes(x = Belief_Answer, y = Participant, fill = Participant)) +
ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups", color = "black", size = 0.1) +
geom_vline(xintercept = 0, linetype = "dotted") +
scale_y_discrete(expand = c(0.02, 0)) +
scale_x_continuous(
limits = c(-1, 1),
expand = c(0, 0),
breaks = c(-0.95, 0, 0.95),
label = c("Fake", "", "Real")
) +
scale_fill_viridis_d() +
labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
guides(fill = "none") +
see::theme_modern() +
theme(
axis.text.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "grey", color = "white") +
ggside::scale_xsidey_continuous(expand = c(0, 0))
df |>
group_by(Participant, Belief) |>
summarize(n = n() / 108,
Confidence = mean(Belief_Confidence)) |>
pivot_wider(values_from=c("n", "Confidence"), names_from="Belief") |>
ungroup() |>
describe_posterior(centrality = "mean", test=FALSE)
## Summary of Posterior Distribution
##
## Parameter | Mean | 95% CI
## -------------------------------------
## n_Fake | 0.44 | [0.12, 0.64]
## n_Real | 0.56 | [0.36, 0.88]
## Confidence_Fake | 0.60 | [0.24, 1.00]
## Confidence_Real | 0.59 | [0.19, 0.99]
m <- glmmTMB::glmmTMB(Belief ~ 1 + (1|Participant) + (1|Stimulus), data=df, family="binomial")
icc(m, by_group = TRUE)
## # ICC by Group
##
## Group | ICC
## -------------------
## Participant | 0.090
## Stimulus | 0.096
Colinearity
IVs <- c("Attractive", "Beauty", "Trustworthy", "Familiar")
correlation::correlation(df[IVs], partial=TRUE)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | r | 95% CI | t(15766) | p
## ----------------------------------------------------------------------------
## Attractive | Beauty | 0.65 | [ 0.64, 0.65] | 106.09 | < .001***
## Attractive | Trustworthy | 0.10 | [ 0.08, 0.11] | 12.41 | < .001***
## Attractive | Familiar | 0.16 | [ 0.14, 0.17] | 20.20 | < .001***
## Beauty | Trustworthy | 0.25 | [ 0.23, 0.26] | 32.37 | < .001***
## Beauty | Familiar | -4.98e-03 | [-0.02, 0.01] | -0.63 | 0.531
## Trustworthy | Familiar | 0.08 | [ 0.06, 0.09] | 9.67 | < .001***
##
## p-value adjustment method: Holm (1979)
## Observations: 15768
preds <- data.frame()
dats <- data.frame()
for (x in IVs) {
for (y in IVs) {
if (x == y) next
print(paste(y, "~", x))
model <- glmmTMB::glmmTMB(as.formula(
paste(y, "~", x, "* Sex * Stimulus_Interest + (1|Participant) + (1|Stimulus)")
),
data = df,
family = glmmTMB::beta_family()
)
# model <- mgcv::gamm(Real ~ s(Attractive) + Trustworthy,
# random = list(Participant=~1, Stimulus=~1),
# data = df,
# family=mgcv::betar())
pred <- estimate_relation(model, at = c(x, "Stimulus_Interest", "Sex"), length = 20)
pred$y <- y
pred <- data_rename(pred, x, "Score")
pred$x <- x
preds <- rbind(preds, pred)
dats <- rbind(dats, data.frame(Score = df[[x]], Predicted = df[[y]], x = x, y = y, Sex = df$Sex))
}
}
## [1] "Beauty ~ Attractive"
## [1] "Trustworthy ~ Attractive"
## [1] "Familiar ~ Attractive"
## [1] "Attractive ~ Beauty"
## [1] "Trustworthy ~ Beauty"
## [1] "Familiar ~ Beauty"
## [1] "Attractive ~ Trustworthy"
## [1] "Beauty ~ Trustworthy"
## [1] "Familiar ~ Trustworthy"
## [1] "Attractive ~ Familiar"
## [1] "Beauty ~ Familiar"
## [1] "Trustworthy ~ Familiar"
dats <- mutate(dats, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
preds <- mutate(preds, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
dats |>
ggplot(aes(x = Score, y = Predicted)) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
# geom_ribbon(data = preds, aes(ymin = CI_low, ymax = CI_high, group = Stimulus_SameSex), alpha = 0.3) +
geom_line(data = preds, aes(color = Sex, linetype = Stimulus_Interest)) +
scale_fill_gradientn(colors = c("white", "#FF9800", "#F44336"), guide = "none") +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_linetype_manual(values = c("TRUE" = "solid", "FALSE" = "dashed")) +
scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
facet_grid(y ~ x, switch = "both") +
theme_modern() +
labs(title = "Collinearity in the Stimuli Ratings") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
axis.title.x = element_blank(),
axis.title.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggnewscale::new_scale_fill() +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
ggside::geom_xsidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
ggside::geom_ysidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
Effect of Delay
model <- glmmTMB::glmmTMB(Belief ~ Delay + (1 | Participant) + (1 | Stimulus),
data = df,
family = "binomial"
)
pred <- estimate_relation(model, at = "Delay", length = 20)
m_conf <- glmmTMB::glmmTMB(Belief_Confidence ~ Belief / Delay + ((Belief / Delay) | Participant) + (1 | Stimulus),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c("Delay", "Belief"), length = 20)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
df |>
ggplot(aes(x = Delay, y = Real)) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_ribbon(data=y_conf, aes(y=Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = y_conf, aes(y = Predicted, group = Belief), linetype = "dashed", color = "red") +
geom_ribbon(data = pred, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = pred, aes(y = Predicted), color = "red") +
scale_fill_gradientn(colors = c("white", "#795548"), guide = "none") +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
theme_modern() +
labs(title = "Effect of Re-exposure Delay", x = "Minutes") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "#795548", color = "white") +
ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
hdi(df$Delay)
## 95% HDI: [1.18, 29.52]
estimate_relation(model, at="Delay=c(0, 60)")
## Model-based Expectation
##
## Delay | Participant | Stimulus | Predicted | SE | 95% CI
## ----------------------------------------------------------------
## 0.00 | | | 0.59 | 0.02 | [0.54, 0.63]
## 60.00 | | | 0.54 | 0.03 | [0.47, 0.60]
##
## Variable predicted: Belief
## Predictors modulated: Delay=c(0, 60)
parameters::parameters(model, effects="fixed", exponentiate=TRUE) |>
display()
Fixed Effects
| (Intercept) |
1.41 |
0.12 |
(1.19, 1.68) |
3.93 |
< .001 |
| Delay |
1.00 |
2.44e-03 |
(0.99, 1.00) |
-1.35 |
0.178 |
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.81 |
0.09 |
(0.63, 0.99) |
8.67 |
< .001 |
| Belief (Real) |
-0.05 |
0.07 |
(-0.17, 0.08) |
-0.69 |
0.491 |
| Belief (Fake) * Delay |
-2.67e-03 |
2.37e-03 |
(-7.32e-03, 1.99e-03) |
-1.12 |
0.261 |
| Belief (Real) * Delay |
-5.89e-03 |
2.06e-03 |
(-9.93e-03, -1.84e-03) |
-2.85 |
0.004 |
Determinants of Reality
make_model <- function(df, var = "Attractive", formula = var, fill = "#2196F3") {
# Models
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", formula)),
data = df,
family = "binomial"
)
y_real <- estimate_relation(m_real, at = c(var, "Sex"), length = 21)
# gam <- brms::brm(paste0("Belief ~ s(", var, ", by=Sex) + (1|Participant) + (1|Stimulus)"),
# data=df,
# algorithm="sampling",
# family = "bernoulli")
# trend <- estimate_relation(gam, at = c(var, "Sex"), length = 81, preserve_range=FALSE)
# slope <- estimate_slopes(gam, trend=var, at = c(var, "Sex"), length = 81)
# trend$Trend <- interpret_pd(slope$pd)
# trend$group <- 0
# trend$group[2:nrow(trend)] <- as.character(cumsum(ifelse(trend$Trend[2:nrow(trend)] == trend$Trend[1:nrow(trend)-1], 0, 1)))
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief /", formula)),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c(var, "Belief", "Sex"), length = 21)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
# Significance
sig1 <- data.frame(x = 0.5,
y = y_real[c(11, 31), "Predicted"],
Sex = y_real[c(11, 31), "Sex"])
param <- parameters::parameters(m_real, effects = "fixed", keep = var)
sig1$p <- c(min(param[str_detect(param$Parameter, sig1$Sex[1]), "p"]), min(param[str_detect(param$Parameter, sig1$Sex[2]), "p"]))
sig1$y <- sig1$y + ifelse(sig1$Sex == "Male", 0.03, -0.03)
sig1$label <- ifelse(sig1$p > .05 & sig1$p < .099, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
sig2 <- data.frame(x = 0.5,
y = y_conf[c(11, 31, 51, 71), "Predicted"],
Sex = y_conf[c(11, 31, 51, 71), "Sex"],
Belief = y_conf[c(11, 31, 51, 71), "Belief"]) |>
arrange(Sex, Belief)
param <- parameters::parameters(m_conf, effects = "fixed", keep = var) |>
arrange(Parameter)
sig2$p <- c(min(param$p[c(1, 2)]), min(param$p[c(5, 6)]), min(param$p[c(3, 4)]), min(param$p[c(7, 8)]))
sig2$y <- sig2$y + ifelse(sig2$Belief == "Real", 0.02, -0.02)
sig2$label <- ifelse(sig2$p > .05 & sig2$p < .099, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
# Plot
p <- df |>
ggplot(aes_string(x = var, y = "Real")) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
scale_fill_gradientn(colors = c("white", fill), guide = "none") +
ggnewscale::new_scale_fill() +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_point2(alpha = 0.25, size = 4, color = "black") +
geom_line(data = y_conf, aes(y = Predicted, group = interaction(Belief, Sex), color = Sex), linetype = "dashed") +
geom_ribbon(data = y_real, aes(y = Predicted, group = Sex, fill = Sex, ymin = CI_low, ymax = CI_high), alpha = 1 / 3) +
geom_line(data = y_real, aes(y = Predicted, color = Sex), size=1) +
# geom_ribbon(data = trend, aes(y = Predicted, group=Sex, fill=Sex, ymin = CI_low, ymax = CI_high), alpha = 1/6) +
# geom_line(data = trend, aes(y = Predicted, color=Sex, linetype=Trend, group=interaction(Sex, group)), size=0.6) +
geom_text(data = sig1, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig1$p < .05, 8.5, 3.5)) +
geom_text(data = sig2, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig2$p < .05, 5, 3)) +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
labs(y = "Simulation Monitoring") +
guides(fill = guide_legend(override.aes = list(alpha = 1))) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(fill = fill, color = "white") +
ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
list(p = p, model_belief = m_real, model_confidence = m_conf)
}
rez_at <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Attractive, 2) + (1|Participant) + (1|Stimulus)",
var = "Attractive", fill = "#F44336"
)
rez_gl <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Beauty, 2) + Trustworthy + Familiar + (1|Participant) + (1|Stimulus)",
var = "Beauty", fill = "#E91E63"
)
rez_tr <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Trustworthy, 2) + Beauty + Familiar + (1|Participant) + (1|Stimulus)",
var = "Trustworthy", fill = "#4CAF50"
)
rez_fa <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Familiar, 2) + Beauty + Trustworthy + (1|Participant) + (1|Stimulus)",
var = "Familiar", fill = "#2196F3"
)
Attractiveness
parameters::parameters(rez_at$model_belief, effects = "fixed", keep = "Attractive") |>
display()
Fixed Effects
| Sex (Female) * poly(Attractive, 2)1 |
5.69 |
3.31 |
(-0.79, 12.18) |
1.72 |
0.085 |
| Sex (Male) * poly(Attractive, 2)1 |
14.40 |
4.54 |
(5.51, 23.29) |
3.17 |
0.002 |
| Sex (Female) * poly(Attractive, 2)2 |
8.26 |
3.15 |
(2.08, 14.43) |
2.62 |
0.009 |
| Sex (Male) * poly(Attractive, 2)2 |
-0.28 |
5.30 |
(-10.66, 10.11) |
-0.05 |
0.959 |
performance::performance(rez_at$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_at$model_belief, by_group = TRUE) |>
display()
| Participant |
0.07 |
| Stimulus |
0.09 |
parameters::parameters(rez_at$model_confidence, effects = "fixed", keep = "Attractive") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Attractive, 2)1 |
0.80 |
2.33 |
(-3.77, 5.37) |
0.34 |
0.732 |
| Belief (Real) * SexFemale * poly(Attractive, 2)1 |
2.88 |
1.85 |
(-0.75, 6.51) |
1.55 |
0.120 |
| Belief (Fake) * SexMale * poly(Attractive, 2)1 |
2.13 |
3.25 |
(-4.24, 8.51) |
0.66 |
0.512 |
| Belief (Real) * SexMale * poly(Attractive, 2)1 |
1.00 |
2.81 |
(-4.50, 6.50) |
0.36 |
0.722 |
| Belief (Fake) * SexFemale * poly(Attractive, 2)2 |
5.44 |
2.28 |
(0.97, 9.91) |
2.38 |
0.017 |
| Belief (Real) * SexFemale * poly(Attractive, 2)2 |
4.43 |
1.74 |
(1.02, 7.85) |
2.54 |
0.011 |
| Belief (Fake) * SexMale * poly(Attractive, 2)2 |
-9.36 |
4.13 |
(-17.44, -1.27) |
-2.27 |
0.023 |
| Belief (Real) * SexMale * poly(Attractive, 2)2 |
5.05 |
3.04 |
(-0.90, 11.00) |
1.66 |
0.096 |
rez_at$p
Beauty
parameters::parameters(rez_gl$model_belief, effects = "fixed", keep = "Beauty")|>
display()
Fixed Effects
| Sex (Female) * poly(Beauty, 2)1 |
4.87 |
3.57 |
(-2.13, 11.87) |
1.36 |
0.172 |
| Sex (Male) * poly(Beauty, 2)1 |
9.48 |
4.22 |
(1.21, 17.76) |
2.25 |
0.025 |
| Sex (Female) * poly(Beauty, 2)2 |
4.47 |
3.22 |
(-1.85, 10.78) |
1.39 |
0.166 |
| Sex (Male) * poly(Beauty, 2)2 |
4.29 |
4.51 |
(-4.55, 13.12) |
0.95 |
0.342 |
performance::performance(rez_gl$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_gl$model_belief, by_group = TRUE)|>
display()
| Participant |
0.07 |
| Stimulus |
0.08 |
parameters::parameters(rez_gl$model_confidence, effects = "fixed", keep = "Beauty") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Beauty, 2)1 |
-0.61 |
2.39 |
(-5.30, 4.08) |
-0.26 |
0.799 |
| Belief (Real) * SexFemale * poly(Beauty, 2)1 |
3.75 |
2.03 |
(-0.22, 7.72) |
1.85 |
0.064 |
| Belief (Fake) * SexMale * poly(Beauty, 2)1 |
-1.06 |
3.05 |
(-7.03, 4.91) |
-0.35 |
0.727 |
| Belief (Real) * SexMale * poly(Beauty, 2)1 |
1.99 |
2.51 |
(-2.93, 6.91) |
0.79 |
0.427 |
| Belief (Fake) * SexFemale * poly(Beauty, 2)2 |
8.13 |
2.33 |
(3.58, 12.69) |
3.50 |
< .001 |
| Belief (Real) * SexFemale * poly(Beauty, 2)2 |
2.22 |
1.92 |
(-1.55, 5.99) |
1.15 |
0.249 |
| Belief (Fake) * SexMale * poly(Beauty, 2)2 |
-6.40 |
3.27 |
(-12.80, 5.57e-03) |
-1.96 |
0.050 |
| Belief (Real) * SexMale * poly(Beauty, 2)2 |
4.22 |
2.65 |
(-0.97, 9.41) |
1.59 |
0.111 |
rez_gl$p
Trustworthiness
parameters::parameters(rez_tr$model_belief, effects = "fixed", keep = "Trustworthy") |>
display()
Fixed Effects
| Sex (Female) * poly(Trustworthy, 2)1 |
6.95 |
3.46 |
(0.17, 13.73) |
2.01 |
0.044 |
| Sex (Male) * poly(Trustworthy, 2)1 |
3.79 |
4.04 |
(-4.13, 11.71) |
0.94 |
0.348 |
| Sex (Female) * poly(Trustworthy, 2)2 |
-0.13 |
3.45 |
(-6.88, 6.63) |
-0.04 |
0.970 |
| Sex (Male) * poly(Trustworthy, 2)2 |
-0.82 |
4.16 |
(-8.98, 7.34) |
-0.20 |
0.844 |
performance::performance(rez_tr$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_tr$model_belief, by_group = TRUE) |>
display()
| Participant |
0.07 |
| Stimulus |
0.08 |
parameters::parameters(rez_tr$model_confidence, effects = "fixed", keep = "Trustworthy") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Trustworthy, 2)1 |
-0.24 |
2.35 |
(-4.85, 4.36) |
-0.10 |
0.918 |
| Belief (Real) * SexFemale * poly(Trustworthy, 2)1 |
2.46 |
2.20 |
(-1.85, 6.77) |
1.12 |
0.263 |
| Belief (Fake) * SexMale * poly(Trustworthy, 2)1 |
-3.09 |
2.85 |
(-8.68, 2.50) |
-1.08 |
0.278 |
| Belief (Real) * SexMale * poly(Trustworthy, 2)1 |
0.44 |
2.39 |
(-4.23, 5.12) |
0.19 |
0.852 |
| Belief (Fake) * SexFemale * poly(Trustworthy, 2)2 |
6.41 |
2.45 |
(1.60, 11.22) |
2.61 |
0.009 |
| Belief (Real) * SexFemale * poly(Trustworthy, 2)2 |
6.48 |
2.12 |
(2.33, 10.64) |
3.06 |
0.002 |
| Belief (Fake) * SexMale * poly(Trustworthy, 2)2 |
-3.44 |
2.90 |
(-9.11, 2.24) |
-1.19 |
0.236 |
| Belief (Real) * SexMale * poly(Trustworthy, 2)2 |
1.35 |
2.54 |
(-3.62, 6.32) |
0.53 |
0.594 |
rez_tr$p
Familiarity
parameters::parameters(rez_fa$model_belief, effects = "fixed", keep = "Familiar") |>
display()
Fixed Effects
| Sex (Female) * poly(Familiar, 2)1 |
0.61 |
3.78 |
(-6.80, 8.02) |
0.16 |
0.872 |
| Sex (Male) * poly(Familiar, 2)1 |
6.98 |
5.02 |
(-2.86, 16.82) |
1.39 |
0.164 |
| Sex (Female) * poly(Familiar, 2)2 |
-0.39 |
3.45 |
(-7.14, 6.37) |
-0.11 |
0.911 |
| Sex (Male) * poly(Familiar, 2)2 |
-4.43 |
4.91 |
(-14.07, 5.20) |
-0.90 |
0.367 |
performance::performance(rez_fa$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_fa$model_belief, by_group = TRUE) |>
display()
| Participant |
0.07 |
| Stimulus |
0.08 |
parameters::parameters(rez_fa$model_confidence, effects = "fixed", keep = "Familiar") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Familiar, 2)1 |
2.23 |
2.59 |
(-2.85, 7.32) |
0.86 |
0.389 |
| Belief (Real) * SexFemale * poly(Familiar, 2)1 |
-0.76 |
2.15 |
(-4.97, 3.45) |
-0.35 |
0.724 |
| Belief (Fake) * SexMale * poly(Familiar, 2)1 |
-7.98 |
3.64 |
(-15.10, -0.85) |
-2.19 |
0.028 |
| Belief (Real) * SexMale * poly(Familiar, 2)1 |
8.39 |
2.98 |
(2.54, 14.24) |
2.81 |
0.005 |
| Belief (Fake) * SexFemale * poly(Familiar, 2)2 |
0.17 |
2.39 |
(-4.52, 4.86) |
0.07 |
0.942 |
| Belief (Real) * SexFemale * poly(Familiar, 2)2 |
-1.07 |
2.02 |
(-5.02, 2.88) |
-0.53 |
0.596 |
| Belief (Fake) * SexMale * poly(Familiar, 2)2 |
6.33 |
4.18 |
(-1.86, 14.52) |
1.51 |
0.130 |
| Belief (Real) * SexMale * poly(Familiar, 2)2 |
-1.13 |
2.85 |
(-6.72, 4.46) |
-0.39 |
0.693 |
rez_fa$p
Inter-Individual Correlates
plot_interindividual <- function(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#D81B60") {
y_real <- estimate_relation(m_real, at = c(var), length = 21)
y_conf <- estimate_relation(m_conf, at = c(var, "Belief"), length = 21)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
# Significance
mid <- max(y_conf[[var]])-diff(range(y_conf[[var]])) / 2
sig1 <- data.frame(x = mid, y = y_real[c(11), "Predicted"] + 0.065,
p = parameters::parameters(m_real, effects = "fixed", keep = var)$p)
sig1$label <- ifelse(sig1$p > .05 & sig1$p < .1, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
sig2 <- data.frame(x = mid, y = y_conf[c(11, 31), "Predicted"] + c(-0.065, 0.065),
p = parameters::parameters(m_conf, effects = "fixed", keep = var)$p,
Belief = y_conf[c(11, 31), "Belief"])
sig2$label <- ifelse(sig2$p > .05 & sig2$p < .1, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
# Data
dat <- insight::get_data(m_conf) |>
group_by(Participant, Belief) |>
data_select(c("Participant", "Belief", var, "Belief_Confidence")) |>
mean_qi(.width = 0.5) |>
mutate(Belief_Confidence = ifelse(Belief == "Real", datawizard::rescale(Belief_Confidence, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(Belief_Confidence, range = c(1, 0), to = c(0, 0.5))))
# Plot
p <- df |>
ggplot(aes_string(x = var, y = "Real")) +
stat_density_2d(data=filter(df, Belief=="Real"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
scale_fill_gradientn(colors = c("white", "#4CAF50"), guide = "none") +
ggnewscale::new_scale_fill() +
stat_density_2d(data=filter(df, Belief=="Fake"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
scale_fill_gradientn(colors = c("white", "#F44336"), guide = "none") +
ggnewscale::new_scale_fill() +
geom_hline(yintercept = 0.5, linetype = "dotted") +
geom_point2(data=dat, aes(y = Belief_Confidence, color = Belief), alpha = 0.25, size = 4) +
geom_ribbon(data = y_conf, aes(y = Predicted, ymin = CI_low, ymax = CI_high, fill = Belief), alpha = 1 / 6) +
geom_line(data = y_conf, aes(y = Predicted, group = Belief, color = Belief)) +
geom_ribbon(data = y_real, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 1 / 6) +
geom_line(data = y_real, aes(y = Predicted), size=1) +
geom_text(data = sig1, aes(y = y, x = x, label = label), size = ifelse(sig1$p < .05, 8, 3.5)) +
geom_text(data = sig2, aes(y = y, x = x, label = label), size = ifelse(sig2$p < .05, 8, 3.5)) +
scale_color_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
scale_fill_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
labs(y = "Simulation Monitoring") +
guides(fill = guide_legend(override.aes = list(alpha = 1))) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(data=dat, fill = fill, color = NA) +
ggside::geom_ysidedensity(data=dat, aes(fill = Belief, y=Belief_Confidence), color = NA) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
p
}
make_correlation <- function(x, y) {
cor <- correlation::correlation(x,
y,
bayesian = TRUE,
bayesian_prior = "medium.narrow",
sort = TRUE
) |>
datawizard::data_remove(c("ROPE_Percentage"))
cor$`BF (Spearman)` <- format_bf(
correlation::correlation(
x, y,
bayesian = TRUE,
ranktransform = TRUE,
bayesian_prior = "medium.narrow"
)$BF,
name = NULL, stars = TRUE
)
cor |>
arrange(desc(BF))
}
IPIP-6
f <- paste0("(",paste(names(select(df, starts_with("IPIP"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.70 |
0.46 |
(-0.21, 1.60) |
1.51 |
0.132 |
| IPIP6 Extraversion |
-0.30 |
0.27 |
(-0.83, 0.24) |
-1.09 |
0.276 |
| IPIP6 Conscientiousness |
-0.12 |
0.28 |
(-0.67, 0.43) |
-0.43 |
0.664 |
| IPIP6 Neuroticism |
-0.34 |
0.31 |
(-0.95, 0.27) |
-1.09 |
0.274 |
| IPIP6 Openness |
-0.05 |
0.32 |
(-0.68, 0.59) |
-0.15 |
0.880 |
| IPIP6 HonestyHumility |
-0.35 |
0.29 |
(-0.92, 0.22) |
-1.21 |
0.226 |
| IPIP6 Agreeableness |
0.27 |
0.34 |
(-0.40, 0.94) |
0.79 |
0.428 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.34 |
0.76 |
(-1.15, 1.84) |
0.45 |
0.653 |
| Belief (Real) |
0.19 |
0.16 |
(-0.12, 0.50) |
1.21 |
0.228 |
| Belief (Fake) * IPIP6 Extraversion |
-0.08 |
0.45 |
(-0.97, 0.81) |
-0.17 |
0.863 |
| Belief (Real) * IPIP6 Extraversion |
-0.20 |
0.45 |
(-1.09, 0.69) |
-0.45 |
0.655 |
| Belief (Fake) * IPIP6 Conscientiousness |
-0.19 |
0.46 |
(-1.10, 0.72) |
-0.41 |
0.682 |
| Belief (Real) * IPIP6 Conscientiousness |
-0.03 |
0.46 |
(-0.94, 0.87) |
-0.07 |
0.941 |
| Belief (Fake) * IPIP6 Neuroticism |
0.15 |
0.52 |
(-0.87, 1.17) |
0.29 |
0.772 |
| Belief (Real) * IPIP6 Neuroticism |
0.26 |
0.52 |
(-0.75, 1.28) |
0.51 |
0.611 |
| Belief (Fake) * IPIP6 Openness |
0.69 |
0.54 |
(-0.37, 1.75) |
1.28 |
0.200 |
| Belief (Real) * IPIP6 Openness |
0.29 |
0.54 |
(-0.77, 1.34) |
0.54 |
0.592 |
| Belief (Fake) * IPIP6 HonestyHumility |
-1.10 |
0.48 |
(-2.05, -0.16) |
-2.28 |
0.022 |
| Belief (Real) * IPIP6 HonestyHumility |
-1.56 |
0.48 |
(-2.50, -0.61) |
-3.24 |
0.001 |
| Belief (Fake) * IPIP6 Agreeableness |
0.87 |
0.57 |
(-0.25, 1.98) |
1.52 |
0.129 |
| Belief (Real) * IPIP6 Agreeableness |
0.99 |
0.57 |
(-0.13, 2.10) |
1.74 |
0.082 |
p_ipip <- plot_interindividual(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#00BCD4") + labs(x = "Honesty-Humility")
p_ipip
sr <- c("Confidence_Fake", "Confidence_Real", "n_Real")
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IPIP")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## -------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | IPIP6_HonestyHumility | -0.20 | [-0.35, -0.04] | 99.42%** | Beta (5.20 +- 5.20) | 6.33* | 4.24*
## Confidence_Fake | IPIP6_Openness | 0.15 | [ 0.00, 0.31] | 96.58% | Beta (5.20 +- 5.20) | 1.45 | 2.47
## Confidence_Fake | IPIP6_Extraversion | 0.14 | [-0.01, 0.29] | 95.95% | Beta (5.20 +- 5.20) | 1.14 | 1.54
## Confidence_Fake | IPIP6_HonestyHumility | -0.14 | [-0.28, 0.02] | 96.05% | Beta (5.20 +- 5.20) | 1.07 | 0.560
##
## Observations: 146
Narcissism
f <- paste0("(",paste(names(select(df, starts_with("FFNI"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.22 |
0.32 |
(-0.41, 0.85) |
0.68 |
0.498 |
| FFNI AcclaimSeeking |
0.81 |
0.33 |
(0.17, 1.46) |
2.47 |
0.014 |
| FFNI Arrogance |
0.08 |
0.32 |
(-0.56, 0.72) |
0.25 |
0.805 |
| FFNI Authoritativeness |
1.55e-03 |
0.31 |
(-0.61, 0.61) |
4.96e-03 |
0.996 |
| FFNI Distrust |
0.21 |
0.28 |
(-0.34, 0.77) |
0.76 |
0.449 |
| FFNI Entitlement |
-0.41 |
0.34 |
(-1.07, 0.25) |
-1.22 |
0.224 |
| FFNI Exhibitionism |
-4.85e-03 |
0.29 |
(-0.57, 0.56) |
-0.02 |
0.987 |
| FFNI Exploitativeness |
0.13 |
0.28 |
(-0.41, 0.68) |
0.48 |
0.629 |
| FFNI GrandioseFantasies |
-0.14 |
0.23 |
(-0.59, 0.32) |
-0.59 |
0.553 |
| FFNI Indifference |
-0.16 |
0.29 |
(-0.73, 0.42) |
-0.54 |
0.590 |
| FFNI LackOfEmpathy |
0.22 |
0.32 |
(-0.40, 0.84) |
0.69 |
0.489 |
| FFNI Manipulativeness |
-0.76 |
0.31 |
(-1.37, -0.14) |
-2.41 |
0.016 |
| FFNI NeedForAdmiration |
-0.15 |
0.31 |
(-0.76, 0.46) |
-0.49 |
0.625 |
| FFNI ReactiveAnger |
0.33 |
0.27 |
(-0.20, 0.86) |
1.23 |
0.219 |
| FFNI Shame |
-0.35 |
0.34 |
(-1.01, 0.31) |
-1.03 |
0.303 |
| FFNI ThrillSeeking |
0.04 |
0.22 |
(-0.39, 0.47) |
0.19 |
0.850 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.70 |
0.53 |
(-0.34, 1.73) |
1.32 |
0.186 |
| Belief (Real) |
-0.19 |
0.11 |
(-0.41, 0.04) |
-1.63 |
0.103 |
| Belief (Fake) * FFNI AcclaimSeeking |
1.67 |
0.55 |
(0.60, 2.74) |
3.07 |
0.002 |
| Belief (Real) * FFNI AcclaimSeeking |
1.70 |
0.54 |
(0.64, 2.77) |
3.14 |
0.002 |
| Belief (Fake) * FFNI Arrogance |
-0.41 |
0.54 |
(-1.47, 0.64) |
-0.77 |
0.442 |
| Belief (Real) * FFNI Arrogance |
-0.64 |
0.54 |
(-1.70, 0.41) |
-1.20 |
0.230 |
| Belief (Fake) * FFNI Authoritativeness |
-1.52 |
0.52 |
(-2.54, -0.50) |
-2.93 |
0.003 |
| Belief (Real) * FFNI Authoritativeness |
-1.62 |
0.52 |
(-2.63, -0.60) |
-3.13 |
0.002 |
| Belief (Fake) * FFNI Distrust |
-0.23 |
0.47 |
(-1.15, 0.69) |
-0.49 |
0.625 |
| Belief (Real) * FFNI Distrust |
0.19 |
0.47 |
(-0.73, 1.11) |
0.41 |
0.685 |
| Belief (Fake) * FFNI Entitlement |
0.16 |
0.56 |
(-0.93, 1.25) |
0.29 |
0.769 |
| Belief (Real) * FFNI Entitlement |
0.58 |
0.55 |
(-0.51, 1.66) |
1.04 |
0.298 |
| Belief (Fake) * FFNI Exhibitionism |
0.11 |
0.48 |
(-0.83, 1.05) |
0.23 |
0.821 |
| Belief (Real) * FFNI Exhibitionism |
5.71e-04 |
0.48 |
(-0.94, 0.94) |
1.19e-03 |
> .999 |
| Belief (Fake) * FFNI Exploitativeness |
-0.47 |
0.46 |
(-1.38, 0.44) |
-1.01 |
0.314 |
| Belief (Real) * FFNI Exploitativeness |
-0.21 |
0.46 |
(-1.12, 0.70) |
-0.45 |
0.652 |
| Belief (Fake) * FFNI GrandioseFantasies |
0.68 |
0.39 |
(-0.07, 1.44) |
1.77 |
0.076 |
| Belief (Real) * FFNI GrandioseFantasies |
0.56 |
0.38 |
(-0.19, 1.31) |
1.45 |
0.146 |
| Belief (Fake) * FFNI Indifference |
-0.05 |
0.49 |
(-1.00, 0.91) |
-0.10 |
0.923 |
| Belief (Real) * FFNI Indifference |
-0.41 |
0.49 |
(-1.36, 0.54) |
-0.84 |
0.400 |
| Belief (Fake) * FFNI LackOfEmpathy |
0.13 |
0.53 |
(-0.90, 1.16) |
0.26 |
0.798 |
| Belief (Real) * FFNI LackOfEmpathy |
0.10 |
0.52 |
(-0.93, 1.12) |
0.19 |
0.852 |
| Belief (Fake) * FFNI Manipulativeness |
0.49 |
0.52 |
(-0.54, 1.51) |
0.93 |
0.351 |
| Belief (Real) * FFNI Manipulativeness |
0.31 |
0.52 |
(-0.71, 1.33) |
0.60 |
0.547 |
| Belief (Fake) * FFNI NeedForAdmiration |
-0.39 |
0.52 |
(-1.40, 0.63) |
-0.75 |
0.456 |
| Belief (Real) * FFNI NeedForAdmiration |
-0.39 |
0.52 |
(-1.41, 0.62) |
-0.76 |
0.448 |
| Belief (Fake) * FFNI ReactiveAnger |
0.48 |
0.45 |
(-0.40, 1.35) |
1.06 |
0.288 |
| Belief (Real) * FFNI ReactiveAnger |
0.48 |
0.45 |
(-0.40, 1.35) |
1.07 |
0.283 |
| Belief (Fake) * FFNI Shame |
-0.44 |
0.56 |
(-1.54, 0.65) |
-0.80 |
0.426 |
| Belief (Real) * FFNI Shame |
-0.53 |
0.56 |
(-1.62, 0.56) |
-0.95 |
0.342 |
| Belief (Fake) * FFNI ThrillSeeking |
-0.55 |
0.36 |
(-1.26, 0.16) |
-1.52 |
0.129 |
| Belief (Real) * FFNI ThrillSeeking |
-0.40 |
0.36 |
(-1.11, 0.31) |
-1.10 |
0.273 |
p_ffni1 <- plot_interindividual(m_real, m_conf, var = "FFNI_AcclaimSeeking", fill = "#FFC107") + labs(x = "Narcissism (Acclaim Seeking)")
p_ffni1
p_ffni2 <- plot_interindividual(m_real, m_conf, var = "FFNI_Authoritativeness", fill = "#FF9800") + labs(x = "Narcissism (Authoritativeness)")
p_ffni2
# p_ffni3 <- plot_interindividual(m_real, m_conf, var = "FFNI_ThrillSeeking", fill = "#FF5722") + labs(x = "Narcissism (Thrill Seeking)")
# p_ffni3
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("FFNI_")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## ---------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | FFNI_AcclaimSeeking | 0.21 | [ 0.06, 0.36] | 99.78%** | Beta (5.20 +- 5.20) | 9.24* | 23.68**
## Confidence_Fake | FFNI_AcclaimSeeking | 0.19 | [ 0.03, 0.33] | 99.15%** | Beta (5.20 +- 5.20) | 4.09* | 4.77*
## Confidence_Fake | FFNI_GrandioseFantasies | 0.19 | [ 0.04, 0.34] | 98.83%* | Beta (5.20 +- 5.20) | 4.00* | 2.65
## Confidence_Real | FFNI_GrandioseFantasies | 0.17 | [ 0.02, 0.31] | 98.55%* | Beta (5.20 +- 5.20) | 2.38 | 2.85
## n_Real | FFNI_Manipulativeness | -0.17 | [-0.32, -0.02] | 98.25%* | Beta (5.20 +- 5.20) | 2.27 | 1.05
## Confidence_Fake | FFNI_Manipulativeness | 0.15 | [ 0.00, 0.31] | 97.15%* | Beta (5.20 +- 5.20) | 1.58 | 1.07
##
## Observations: 146
cor_test(dfsub, "FFNI_Authoritativeness", "IPIP6_HonestyHumility")
## Parameter1 | Parameter2 | r | 95% CI | t(144) | p
## --------------------------------------------------------------------------------------------
## FFNI_Authoritativeness | IPIP6_HonestyHumility | -0.35 | [-0.49, -0.20] | -4.49 | < .001***
##
## Observations: 146
# cor_test(dfsub, "FFNI_ThrillSeeking", "IPIP6_HonestyHumility")
Social Anxiety
f <- paste0("(",paste(names(select(df, starts_with("Social_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.25 |
0.14 |
(-0.02, 0.52) |
1.81 |
0.070 |
| Social Anxiety |
0.41 |
0.41 |
(-0.39, 1.21) |
1.01 |
0.311 |
| Social Phobia |
-0.29 |
0.36 |
(-0.99, 0.42) |
-0.79 |
0.430 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.93 |
0.21 |
(0.52, 1.34) |
4.42 |
< .001 |
| Belief (Real) |
-0.22 |
0.04 |
(-0.30, -0.14) |
-5.23 |
< .001 |
| Belief (Fake) * Social Anxiety |
-1.17 |
0.70 |
(-2.54, 0.19) |
-1.69 |
0.092 |
| Belief (Real) * Social Anxiety |
-0.80 |
0.69 |
(-2.16, 0.56) |
-1.15 |
0.248 |
| Belief (Fake) * Social Phobia |
0.94 |
0.62 |
(-0.27, 2.15) |
1.52 |
0.129 |
| Belief (Real) * Social Phobia |
0.71 |
0.62 |
(-0.50, 1.92) |
1.15 |
0.249 |
# p_social <- plot_interindividual(m_real, m_conf, var = "Social_Phobia", fill = "#E040FB") + labs(x = "Social Phobia")
# p_social
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("Social_")))
filter(r, BF > 1)
Intolerance to Uncertainty
f <- paste0("(",paste(names(select(df, starts_with("IUS_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.46 |
0.22 |
(0.02, 0.90) |
2.07 |
0.039 |
| IUS ProspectiveAnxiety |
-0.08 |
0.40 |
(-0.87, 0.72) |
-0.19 |
0.849 |
| IUS InhibitoryAnxiety |
-0.25 |
0.31 |
(-0.86, 0.35) |
-0.82 |
0.412 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.62 |
0.37 |
(-0.11, 1.34) |
1.67 |
0.094 |
| Belief (Real) |
-0.29 |
0.08 |
(-0.43, -0.14) |
-3.77 |
< .001 |
| Belief (Fake) * IUS ProspectiveAnxiety |
0.99 |
0.69 |
(-0.36, 2.33) |
1.44 |
0.151 |
| Belief (Real) * IUS ProspectiveAnxiety |
1.24 |
0.68 |
(-0.10, 2.58) |
1.81 |
0.070 |
| Belief (Fake) * IUS InhibitoryAnxiety |
-0.85 |
0.53 |
(-1.88, 0.18) |
-1.62 |
0.106 |
| Belief (Real) * IUS InhibitoryAnxiety |
-0.94 |
0.52 |
(-1.97, 0.09) |
-1.79 |
0.074 |
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IUS_")))
filter(r, BF > 1)
Paranoid Beliefs
f <- paste0("(",paste(names(select(df, starts_with("GPTS_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.37 |
0.12 |
(0.13, 0.61) |
2.99 |
0.003 |
| GPTS Reference |
-0.64 |
0.36 |
(-1.34, 0.06) |
-1.81 |
0.071 |
| GPTS Persecution |
0.61 |
0.32 |
(-0.02, 1.25) |
1.89 |
0.059 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
1.07 |
0.19 |
(0.70, 1.43) |
5.75 |
< .001 |
| Belief (Real) |
-0.21 |
0.04 |
(-0.29, -0.14) |
-5.66 |
< .001 |
| Belief (Fake) * GPTS Reference |
-0.89 |
0.61 |
(-2.09, 0.32) |
-1.44 |
0.150 |
| Belief (Real) * GPTS Reference |
-0.95 |
0.61 |
(-2.16, 0.25) |
-1.56 |
0.120 |
| Belief (Fake) * GPTS Persecution |
0.40 |
0.56 |
(-0.69, 1.50) |
0.72 |
0.471 |
| Belief (Real) * GPTS Persecution |
0.69 |
0.56 |
(-0.41, 1.78) |
1.23 |
0.218 |
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("GPTS_")))
filter(r, BF > 1)
AI
rez <- parameters::n_factors(select(dfsub, starts_with("AI")))
plot(rez)
efa <- parameters::factor_analysis(select(dfsub, starts_with("AI")), n = 3, rotation = "varimax", sort = TRUE)
efa
## # Rotated loadings from Factor Analysis (varimax-rotation)
##
## Variable | MR1 | MR2 | MR3 | Complexity | Uniqueness
## -----------------------------------------------------------------------
## AI_8_Exciting | 0.82 | 0.16 | 0.18 | 1.18 | 0.27
## AI_4_DailyLife | 0.77 | 0.15 | 0.16 | 1.18 | 0.36
## AI_9_Applications | 0.71 | 0.06 | 0.12 | 1.07 | 0.47
## AI_7_RealisticVideos | 0.09 | 0.79 | 0.12 | 1.07 | 0.36
## AI_5_ImitatingReality | 0.28 | 0.64 | 0.01 | 1.38 | 0.51
## AI_1_RealisticImages | 0.19 | 0.54 | 0.09 | 1.30 | 0.66
## AI_3_VideosReal | -0.13 | 0.41 | -0.21 | 1.71 | 0.77
## AI_2_Unethical | 0.20 | 0.07 | 0.72 | 1.17 | 0.44
## AI_6_Dangerous | 0.15 | -0.12 | 0.61 | 1.20 | 0.59
## AI_10_FaceErrors | 0.02 | 0.04 | 0.25 | 1.06 | 0.94
##
## The 3 latent factors (varimax rotation) accounted for 46.35% of the total variance of the original data (MR1 = 19.69%, MR2 = 15.69%, MR3 = 10.97%).
dfsub <- predict(efa, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
cbind(dfsub)
df <- predict(efa, newdata=df, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
cbind(df)
f <- paste0("(AI_Enthusiasm + AI_Realness + AI_Danger) + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.30 |
0.08 |
(0.14, 0.45) |
3.72 |
< .001 |
| AI Enthusiasm |
-0.02 |
0.06 |
(-0.14, 0.09) |
-0.42 |
0.671 |
| AI Realness |
0.06 |
0.06 |
(-0.06, 0.17) |
0.92 |
0.356 |
| AI Danger |
0.11 |
0.07 |
(-0.02, 0.24) |
1.68 |
0.092 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.85 |
0.09 |
(0.68, 1.02) |
9.62 |
< .001 |
| Belief (Real) |
-0.16 |
0.02 |
(-0.20, -0.13) |
-8.88 |
< .001 |
| Belief (Fake) * AI Enthusiasm |
0.31 |
0.10 |
(0.11, 0.50) |
3.10 |
0.002 |
| Belief (Real) * AI Enthusiasm |
0.20 |
0.10 |
(0.01, 0.40) |
2.09 |
0.037 |
| Belief (Fake) * AI Realness |
0.09 |
0.10 |
(-0.10, 0.29) |
0.93 |
0.351 |
| Belief (Real) * AI Realness |
0.13 |
0.10 |
(-0.07, 0.33) |
1.28 |
0.202 |
| Belief (Fake) * AI Danger |
-0.06 |
0.11 |
(-0.28, 0.15) |
-0.58 |
0.561 |
| Belief (Real) * AI Danger |
0.06 |
0.11 |
(-0.15, 0.28) |
0.58 |
0.560 |
p_ai <- plot_interindividual(m_real, m_conf, var = "AI_Enthusiasm", fill = "#607D8B") +
labs(x = "Enthusiasm about AI technology")
p_ai
r <- make_correlation(dfsub[sr], select(dfsub, AI_Enthusiasm, AI_Realness, AI_Danger))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## ---------------------------------------------------------------------------------------------------------------
## Confidence_Fake | AI_Enthusiasm | 0.22 | [ 0.05, 0.35] | 99.67%** | Beta (5.20 +- 5.20) | 9.69* | 13.87**
## Confidence_Real | AI_Enthusiasm | 0.17 | [ 0.01, 0.32] | 98.47%* | Beta (5.20 +- 5.20) | 2.42 | 2.42
## Confidence_Fake | AI_Realness | 0.14 | [-0.02, 0.28] | 96.17% | Beta (5.20 +- 5.20) | 1.25 | 1.75
##
## Observations: 146
Figures
fig1a <- (rez_at$p +
theme(axis.text.x = element_blank()) +
labs(x = "Attractiveness") |
rez_gl$p +
labs(x = "Beauty") +
theme(
axis.text.x = element_blank(),
axis.title.y = element_blank(),
axis.text.y = element_blank()
)
) /
(rez_tr$p +
labs(x = "Trustworthiness") |
rez_fa$p +
labs(x = "Familiarity") +
theme(
axis.text.y = element_blank(),
axis.title.y = element_blank()
)
) +
plot_annotation(title = "Determinants of Reality Beliefs", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) +
plot_layout(guides = "collect") &
theme(legend.position='top', legend.title = element_blank())
fig <- wrap_elements(fig1a) /
wrap_elements(
# ((p_ffni1 / p_ipip) | (p_ffni2 / p_social) | (p_ffni3 / p_ai)) +
((p_ffni1 / p_ipip) | (p_ffni2 / p_ai)) +
plot_layout(guides = "collect") +
plot_annotation(title = "Personality Correlates of Simulation Monitoring Tendencies", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
) +
plot_layout(heights = c(1.1, 0.9))
ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
plot_correlation <- function(dfsub, x = "Confidence_Real", y = "IPIP6_Openness", xlab = x, ylab = y, fill = "grey", fillx = "purple") {
param <- cor_test(dfsub, x, y, bayesian = TRUE)
# Format stat output
r <- str_replace(str_remove(insight::format_value(param$rho), "^0+"), "^-0+", "-")
CI_low <- str_replace(str_remove(insight::format_value(param$CI_low), "^0+"), "^-0+", "-")
CI_high <- str_replace(str_remove(insight::format_value(param$CI_high), "^0+"), "^-0+", "-")
stat <- paste0("italic(r)~'= ", r, ", 95% CI [", CI_low, ", ", CI_high, "], BF'['10']~'", paste0(insight::format_bf(param$BF, name = "")), "'")
label <- data.frame(
x = min(dfsub[[x]], na.rm = TRUE),
y = max(dfsub[[y]], na.rm = TRUE),
label = stat
)
# Plot
dfsub |>
ggplot(aes_string(x = x, y = y)) +
geom_point2(
size = 3,
color = fillx,
# color = DVs[x],
alpha = 2 / 3
) +
geom_smooth(method = "lm", color = "black", formula = "y ~ x", alpha = 0.3) +
labs(y = ylab, x = xlab) +
geom_label(data = label, aes(x = x, y = y), label = str2expression(label$label), hjust = 0, vjust = 1, size=rel(3.5)) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(fill = fillx, color = "white") +
ggside::geom_ysidedensity(fill = fill, color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
}
p1 <- plot_correlation(dfsub,
x = "IPIP6_HonestyHumility",
y = "Confidence_Real",
ylab = "Confidence that the stimulus is real",
xlab = "Honesty-Humility",
fillx = "#00BCD4",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p2 <- plot_correlation(dfsub,
y = "Confidence_Fake",
x = "AI_Enthusiasm",
ylab = "Confidence that the stimulus is fake",
xlab = "Enthusiasm about AI technology",
fillx = "#607D8B",
fill = "#3F51B5"
) +
scale_y_continuous(labels=scales::percent)
p3 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "AI_Enthusiasm",
ylab = "Confidence that the stimulus is real",
xlab = "Enthusiasm about AI technology",
fillx = "#607D8B",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p4 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "FFNI_AcclaimSeeking",
ylab = "Confidence that the stimulus is real",
xlab = "Narcissism (Acclaim Seeking)",
fillx = "#FF9800",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p5 <- plot_correlation(dfsub,
y = "Confidence_Fake",
x = "FFNI_AcclaimSeeking",
ylab = "Confidence that the stimulus is fake",
xlab = "Narcissism (Acclaim Seeking)",
fillx = "#FF9800",
fill = "#3F51B5"
) +
scale_y_continuous(labels=scales::percent)
p6 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "FFNI_GrandioseFantasies",
ylab = "Confidence that the stimulus is real",
xlab = "Narcissism (Grandiose Fantasies)",
fillx = "#FFC107",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
fig <- wrap_elements(fig1a) /
wrap_elements(
((p3 / p2) | (p1 / p6) | (p4 / p5)) +
plot_annotation(title = "Personality Correlates of Simulation Monitoring", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
) +
plot_layout(heights = c(1.1, 0.9))
ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
Social Anxiety